home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / The World of Computer Software.iso / srcuc.zip / PSBTOBIN.C < prev    next >
C/C++ Source or Header  |  1992-02-11  |  32KB  |  1,255 lines
  1. /* -*-C-*-
  2.  
  3. $Header: /scheme/src/microcode/RCS/Psbtobin.c,v 9.47 1992/02/11 21:14:23 mhwu Exp $
  4.  
  5. Copyright (c) 1987-1992 Massachusetts Institute of Technology
  6.  
  7. This material was developed by the Scheme project at the Massachusetts
  8. Institute of Technology, Department of Electrical Engineering and
  9. Computer Science.  Permission to copy this software, to redistribute
  10. it, and to use it for any purpose is granted, subject to the following
  11. restrictions and understandings.
  12.  
  13. 1. Any copy made of this software must include this copyright notice
  14. in full.
  15.  
  16. 2. Users of this software agree to make their best efforts (a) to
  17. return to the MIT Scheme project any improvements or extensions that
  18. they make, so that these may be included in future releases; and (b)
  19. to inform MIT of noteworthy uses of this software.
  20.  
  21. 3. All materials developed as a consequence of the use of this
  22. software shall duly acknowledge such use, in accordance with the usual
  23. standards of acknowledging credit in academic research.
  24.  
  25. 4. MIT has made no warrantee or representation that the operation of
  26. this software will be error-free, and MIT is under no obligation to
  27. provide any services, by way of maintenance, update, or otherwise.
  28.  
  29. 5. In conjunction with products arising from the use of this material,
  30. there shall be no use of the name of the Massachusetts Institute of
  31. Technology nor of any adaptation thereof in any advertising,
  32. promotional, or sales literature without prior written consent from
  33. MIT in each case. */
  34.  
  35. /* This file contains the code to translate portable format binary
  36.    files to internal format. */
  37.  
  38. /* Cheap renames */
  39.  
  40. #include "psbmap.h"
  41. #include "float.h"
  42. #include "limits.h"
  43. #define portable_file input_file
  44. #define internal_file output_file
  45.  
  46. static Boolean
  47.   band_p = false,
  48.   allow_compiled_p = false,
  49.   allow_nmv_p = false;
  50.  
  51. static long
  52.   Dumped_Object_Addr,
  53.   Dumped_Heap_Base, Heap_Objects, Heap_Count,
  54.   Dumped_Constant_Base, Constant_Objects, Constant_Count,
  55.   Dumped_Pure_Base, Pure_Objects, Pure_Count,
  56.   Primitive_Table_Length;
  57.  
  58. static SCHEME_OBJECT
  59.   *Heap,
  60.   *Heap_Base, *Heap_Table, *Heap_Object_Base, *Free,
  61.   *Constant_Base, *Constant_Table,
  62.   *Constant_Object_Base, *Free_Constant,
  63.   *Pure_Base, *Pure_Table, *Pure_Object_Base, *Free_Pure,
  64.   *primitive_table, *primitive_table_end,
  65.   *Stack_Top;
  66.  
  67. long
  68. DEFUN (Write_Data, (Count, From_Where),
  69.        long Count AND
  70.        SCHEME_OBJECT *From_Where)
  71. {
  72.   return (fwrite (((char *) From_Where),
  73.           (sizeof (SCHEME_OBJECT)),
  74.           Count,
  75.           internal_file));
  76. }
  77.  
  78. #include "fasl.h"
  79. #include "dump.c"
  80.  
  81. void
  82. DEFUN_VOID (inconsistency)
  83. {
  84.   /* Provide some context (2 lines). */
  85.   char yow[100];
  86.  
  87.   fgets (&yow[0], 100, portable_file);
  88.   fprintf (stderr, "%s\n", &yow[0]);
  89.   fgets (&yow[0], 100, portable_file);
  90.   fprintf (stderr, "%s\n", &yow[0]);
  91.  
  92.   quit (1);
  93.   /*NOTREACHED*/
  94. }
  95.  
  96. #define OUT(c)    return ((long) ((c) & UCHAR_MAX))
  97.  
  98. long
  99. DEFUN_VOID (read_a_char)
  100. {
  101.   fast char C;
  102.  
  103.   C = getc (portable_file);
  104.   if (C != '\\')
  105.   {
  106.     OUT (C);
  107.   }
  108.   C = getc (portable_file);
  109.   switch (C)
  110.   {
  111.     case 'n':  OUT ('\n');
  112.     case 't':  OUT ('\t');
  113.     case 'b':  OUT ('\b');
  114.     case 'r':  OUT ('\r');
  115.     case 'f':  OUT ('\f');
  116.     case '\\': OUT ('\\');
  117.     case '0':  OUT ('\0');
  118.     case 'X':
  119.     {
  120.       long Code;
  121.  
  122.       fprintf (stderr,
  123.            "%s: File is not Portable.  Character Code Found.\n",
  124.            program_name);
  125.       fscanf (portable_file, "%ld", &Code);
  126.       getc (portable_file);            /* Space */
  127.       OUT (Code);
  128.     }
  129.     default  : OUT (C);
  130.   }
  131. }
  132.  
  133. SCHEME_OBJECT *
  134. DEFUN (read_a_string_internal, (To, maxlen),
  135.        SCHEME_OBJECT *To AND
  136.        long maxlen)
  137. {
  138.   long ilen, Pointer_Count;
  139.   fast char *str;
  140.   fast long len;
  141.  
  142.   str = ((char *) (&To[STRING_CHARS]));
  143.   fscanf (portable_file, "%ld", &ilen);
  144.   len = ilen;
  145.  
  146.   if (maxlen == -1)
  147.   {
  148.     maxlen = len;
  149.   }
  150.  
  151.   /* Null terminated */
  152.  
  153.   maxlen += 1;
  154.  
  155.   Pointer_Count = STRING_CHARS + (char_to_pointer (maxlen));
  156.   To[STRING_HEADER] =
  157.     (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, (Pointer_Count - 1)));
  158.   To[STRING_LENGTH_INDEX] = ((SCHEME_OBJECT) len);
  159.  
  160.   /* Space */
  161.  
  162.   getc (portable_file);
  163.   while (--len >= 0)
  164.   {
  165.     *str++ = ((char) read_a_char ());
  166.   }
  167.   *str = '\0';
  168.   return (To + Pointer_Count);
  169. }
  170.  
  171. SCHEME_OBJECT *
  172. DEFUN (read_a_string, (To, Slot),
  173.        SCHEME_OBJECT *To AND
  174.        SCHEME_OBJECT *Slot)
  175. {
  176.   long maxlen;
  177.  
  178.   *Slot = (MAKE_POINTER_OBJECT (TC_CHARACTER_STRING, To));
  179.   fscanf (portable_file, "%ld", &maxlen);
  180.   return (read_a_string_internal (To, maxlen));
  181. }
  182.  
  183. /*
  184.    The following two lines appears by courtesy of your friendly
  185.    VMS C compiler and runtime library.
  186.  
  187.    Bug in version 4 VMS scanf.
  188.  */
  189.  
  190. #ifndef vms
  191.  
  192. #define VMS_BUG(stmt)
  193.  
  194. #define read_hex_digit(var)                        \
  195. {                                    \
  196.   fscanf (portable_file, "%1lx", &var);                    \
  197. }
  198.  
  199. #else
  200.  
  201. #define VMS_BUG(stmt)            stmt
  202.  
  203. #define read_hex_digit (var)                        \
  204. {                                    \
  205.   var = (read_hex_digit_procedure ());                    \
  206. }
  207.  
  208. long
  209. read_hex_digit_procedure ()
  210. {
  211.   long digit;
  212.   int c;
  213.  
  214.   while ((c = fgetc (portable_file)) == ' ')
  215.   {};
  216.   digit = ((c >= 'a') ? (c - 'a' + 10)
  217.        : ((c >= 'A') ? (c - 'A' + 10)
  218.           : ((c >= '0') ? (c - '0')
  219.              : fprintf (stderr, "Losing big: %d\n", c))));
  220.   return (digit);
  221. }
  222.  
  223. #endif
  224.  
  225. SCHEME_OBJECT *
  226. DEFUN (read_an_integer, (The_Type, To, Slot),
  227.        int The_Type AND
  228.        SCHEME_OBJECT *To AND
  229.        SCHEME_OBJECT *Slot)
  230. {
  231.   Boolean negative;
  232.   fast long length_in_bits;
  233.  
  234.   getc (portable_file);                /* Space */
  235.   negative = ((getc (portable_file)) == '-');
  236.   {
  237.     long l;
  238.     fscanf (portable_file, "%ld", (&l));
  239.     length_in_bits = l;
  240.   }
  241.   if ((length_in_bits <= fixnum_to_bits) &&
  242.       (The_Type == TC_FIXNUM))
  243.   {
  244.     fast long Value = 0;
  245.     fast int Normalization;
  246.     fast long ndigits;
  247.     long digit;
  248.  
  249.     if (length_in_bits != 0)
  250.     {
  251.       for (Normalization = 0,
  252.       ndigits = hex_digits (length_in_bits);
  253.       --ndigits >= 0;
  254.       Normalization += 4)
  255.       {
  256.     read_hex_digit (digit);
  257.     Value += (digit << Normalization);
  258.       }
  259.     }
  260.     if (negative)
  261.     {
  262.       Value = -Value;
  263.     }
  264.     *Slot = (LONG_TO_FIXNUM (Value));
  265.     return (To);
  266.   }
  267.   else if (length_in_bits == 0)
  268.     {
  269.       SCHEME_OBJECT bignum = (MAKE_POINTER_OBJECT (TC_BIG_FIXNUM, To));
  270.       long gc_length = (BIGNUM_LENGTH_TO_GC_LENGTH (0));
  271.       (*To) = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, gc_length));
  272.       BIGNUM_SET_HEADER (bignum, 0, 0);
  273.       (*Slot) = bignum;
  274.       return (To + gc_length + 1);
  275.     }
  276.   else
  277.     {
  278.       SCHEME_OBJECT bignum = (MAKE_POINTER_OBJECT (TC_BIG_FIXNUM, To));
  279.       bignum_length_type length = (BIGNUM_BITS_TO_DIGITS (length_in_bits));
  280.       long gc_length = (BIGNUM_LENGTH_TO_GC_LENGTH (length));
  281.       bignum_digit_type * scan = (BIGNUM_START_PTR (bignum));
  282.       fast bignum_digit_type accumulator = 0;
  283.       fast int bits_in_digit =
  284.     ((length_in_bits < BIGNUM_DIGIT_LENGTH)
  285.      ? length_in_bits
  286.      : BIGNUM_DIGIT_LENGTH);
  287.       fast int position = 0;
  288.       int hex_digit;
  289.       while (length_in_bits > 0)
  290.     {
  291.       read_hex_digit (hex_digit);
  292.       if (bits_in_digit > 4)
  293.         {
  294.           accumulator |= (hex_digit << position);
  295.           length_in_bits -= 4;
  296.           position += 4;
  297.           bits_in_digit -= 4;
  298.         }
  299.       else if (bits_in_digit == 4)
  300.         {
  301.           (*scan++) = (accumulator | (hex_digit << position));
  302.           accumulator = 0;
  303.           position = 0;
  304.           length_in_bits -= 4;
  305.           bits_in_digit =
  306.         ((length_in_bits < BIGNUM_DIGIT_LENGTH)
  307.          ? length_in_bits
  308.          : BIGNUM_DIGIT_LENGTH);
  309.         }
  310.       else
  311.         {
  312.           (*scan++) =
  313.         (accumulator |
  314.          ((hex_digit & ((1 << bits_in_digit) - 1)) << position));
  315.           accumulator = (hex_digit >> bits_in_digit);
  316.           position = (4 - bits_in_digit);
  317.           length_in_bits -= 4;
  318.           if (length_in_bits >= BIGNUM_DIGIT_LENGTH)
  319.         bits_in_digit = BIGNUM_DIGIT_LENGTH;
  320.           else if (length_in_bits > 0)
  321.         bits_in_digit = length_in_bits;
  322.           else
  323.         {
  324.           (*scan) = accumulator;
  325.           break;
  326.         }
  327.         }
  328.     }
  329.       (*To) = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, gc_length));
  330.       BIGNUM_SET_HEADER (bignum, length, negative);
  331.       (*Slot) = bignum;
  332.       return (To + gc_length + 1);
  333.     }
  334. }
  335.  
  336. SCHEME_OBJECT *
  337. DEFUN (read_a_bit_string, (To, Slot),
  338.        SCHEME_OBJECT *To AND
  339.        SCHEME_OBJECT *Slot)
  340. {
  341.   long size_in_bits, size_in_words;
  342.   SCHEME_OBJECT the_bit_string;
  343.  
  344.   fscanf (portable_file, "%ld", &size_in_bits);
  345.   size_in_words = (1 + (BIT_STRING_LENGTH_TO_GC_LENGTH (size_in_bits)));
  346.  
  347.   the_bit_string = (MAKE_POINTER_OBJECT (TC_BIT_STRING, To));
  348.   *To++ = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, size_in_words));
  349.   *To = size_in_bits;
  350.   To += size_in_words;
  351.  
  352.   if (size_in_bits != 0)
  353.   {
  354.     unsigned long temp;
  355.     fast SCHEME_OBJECT *scan;
  356.     fast long bits_remaining, bits_accumulated;
  357.     fast SCHEME_OBJECT accumulator, next_word;
  358.  
  359.     accumulator = 0;
  360.     bits_accumulated = 0;
  361.     scan = (BIT_STRING_LOW_PTR (the_bit_string));
  362.     for (bits_remaining = size_in_bits;
  363.     bits_remaining > 0;
  364.     bits_remaining -= 4)
  365.     {
  366.       read_hex_digit (temp);
  367.       if ((bits_accumulated + 4) > OBJECT_LENGTH)
  368.       {
  369.     accumulator |=
  370.       ((temp & LOW_MASK (OBJECT_LENGTH - bits_accumulated)) <<
  371.        bits_accumulated);
  372.     *(INC_BIT_STRING_PTR (scan)) = accumulator;
  373.     accumulator = (temp >> (OBJECT_LENGTH - bits_accumulated));
  374.     bits_accumulated -= (OBJECT_LENGTH - 4);
  375.     temp &= LOW_MASK (bits_accumulated);
  376.       }
  377.       else
  378.       {
  379.     accumulator |= (temp << bits_accumulated);
  380.     bits_accumulated += 4;
  381.       }
  382.     }
  383.     if (bits_accumulated != 0)
  384.     {
  385.       *(INC_BIT_STRING_PTR (scan)) = accumulator;
  386.     }
  387.   }
  388.   *Slot = the_bit_string;
  389.   return (To);
  390. }
  391.  
  392. /* Underflow and Overflow */
  393.  
  394. /* dflmax and dflmin exist in the Berserkely FORTRAN library */
  395.  
  396. static double the_max = 0.0;
  397.  
  398. #define dflmin()    0.0    /* Cop out */
  399. #define dflmax()    ((the_max == 0.0) ? (compute_max ()) : the_max)
  400.  
  401. double
  402. DEFUN_VOID (compute_max)
  403. {
  404.   fast double Result;
  405.   fast int expt;
  406.  
  407.   Result = 0.0;
  408.   for (expt = DBL_MAX_EXP;
  409.        expt != 0;
  410.        expt >>= 1)
  411.   {
  412.     Result += (ldexp (1.0, expt));
  413.   }
  414.   the_max = Result;
  415.   return (Result);
  416. }
  417.  
  418. long
  419. DEFUN (read_signed_decimal, (stream),
  420.        fast FILE *stream)
  421. {
  422.   fast int c = (getc (stream));
  423.   fast long result = (-1);
  424.   int negative_p = 0;
  425.   while (c == ' ')
  426.   {
  427.     c = (getc (stream));
  428.   }
  429.   if (c == '-')
  430.   {
  431.     negative_p = 1;
  432.     c = (getc (stream));
  433.   }
  434.   else if (c == '+')
  435.   {
  436.     c = (getc (stream));
  437.   }
  438.   if ((c >= '0') && (c <= '9'))
  439.   {
  440.     result = (c - '0');
  441.     c = (getc (stream));
  442.     while ((c >= '0') && (c <= '9'))
  443.     {
  444.       result = ((result * 10) + (c - '0'));
  445.       c = (getc (stream));
  446.     }
  447.   }
  448.   if (c != EOF)
  449.   {
  450.     ungetc (c, stream);
  451.   }
  452.   if (result == (-1))
  453.   {
  454.     fprintf (stderr, "%s: Unable to read expected decimal integer\n",
  455.          program_name);
  456.     inconsistency ();
  457.   }
  458.   return (negative_p ? (-result) : result);
  459. }
  460.  
  461. double
  462. DEFUN_VOID (read_a_flonum)
  463. {
  464.   Boolean negative;
  465.   long exponent;
  466.   long size_in_bits;
  467.   fast double Result;
  468.  
  469.   getc (portable_file);                /* Space */
  470.   negative = ((getc (portable_file)) == '-');
  471.   /* Hair here because portable file format incorrect for flonum 0. */
  472.   exponent = (read_signed_decimal (portable_file));
  473.   if (exponent == 0)
  474.     {
  475.       int c = (getc (portable_file));
  476.       if (c == '\n')
  477.       {
  478.     return (0);
  479.       }
  480.       ungetc (c, portable_file);
  481.     }
  482.   size_in_bits = (read_signed_decimal (portable_file));
  483.   if (size_in_bits == 0)
  484.   {
  485.     return (0);
  486.   }
  487.   if ((exponent > DBL_MAX_EXP) || (exponent < DBL_MIN_EXP))
  488.   {
  489.     /* Skip over mantissa */
  490.  
  491.     while ((getc (portable_file)) != '\n')
  492.     {};
  493.     fprintf (stderr,
  494.          "%s: Floating point exponent too %s!\n",
  495.          program_name,
  496.          ((exponent < 0) ? "small" : "large"));
  497.     Result = ((exponent < 0) ? (dflmin ()) : (dflmax ()));
  498.   }
  499.   else
  500.   {
  501.     fast long ndigits;
  502.     fast double Normalization;
  503.     long digit;
  504.  
  505.     if (size_in_bits > DBL_MANT_DIG)
  506.     {
  507.       fprintf (stderr,
  508.            "%s: Some precision may be lost.",
  509.            program_name);
  510.     }
  511.     getc (portable_file);            /* Space */
  512.     for (ndigits = (hex_digits (size_in_bits)),
  513.      Result = 0.0,
  514.      Normalization = (1.0 / 16.0);
  515.      --ndigits >= 0;
  516.      Normalization /= 16.0)
  517.     {
  518.       read_hex_digit (digit);
  519.       Result += (((double ) digit) * Normalization);
  520.     }
  521.     Result = (ldexp (Result, ((int) exponent)));
  522.   }
  523.   if (negative)
  524.   {
  525.     Result = -Result;
  526.   }
  527.   return (Result);
  528. }
  529.  
  530. SCHEME_OBJECT *
  531. DEFUN (Read_External, (N, Table, To),
  532.        long N AND
  533.        fast SCHEME_OBJECT *Table AND
  534.        SCHEME_OBJECT *To)
  535. {
  536.   fast SCHEME_OBJECT *Until = &Table[N];
  537.   int The_Type;
  538.  
  539.   while (Table < Until)
  540.   {
  541.     fscanf (portable_file, "%2x", &The_Type);
  542.     switch (The_Type)
  543.     {
  544.       case TC_CHARACTER_STRING:
  545.         To = (read_a_string (To, Table++));
  546.     continue;
  547.  
  548.       case TC_BIT_STRING:
  549.     To = (read_a_bit_string (To, Table++));
  550.     continue;
  551.  
  552.       case TC_FIXNUM:
  553.       case TC_BIG_FIXNUM:
  554.     To = (read_an_integer (The_Type, To, Table++));
  555.     continue;
  556.  
  557.       case TC_CHARACTER:
  558.       {
  559.     long the_char_code;
  560.  
  561.     getc (portable_file);    /* Space */
  562.     VMS_BUG (the_char_code = 0);
  563.     fscanf (portable_file, "%3lx", &the_char_code);
  564.     *Table++ = (MAKE_OBJECT (TC_CHARACTER, the_char_code));
  565.     continue;
  566.       }
  567.  
  568.       case TC_BIG_FLONUM:
  569.       {
  570.     double The_Flonum = (read_a_flonum ());
  571.  
  572.     ALIGN_FLOAT (To);
  573.     *Table++ = (MAKE_POINTER_OBJECT (TC_BIG_FLONUM, To));
  574.     *To++ = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, (float_to_pointer)));
  575.     *((double *) To) = The_Flonum;
  576.     To += float_to_pointer;
  577.     continue;
  578.       }
  579.  
  580.       default:
  581.     fprintf (stderr,
  582.          "%s: Unknown external object found; Type = 0x%02x\n",
  583.          program_name, The_Type);
  584.     inconsistency ();
  585.     /*NOTREACHED*/
  586.     }
  587.   }
  588.   return (To);
  589. }
  590.  
  591. #if FALSE
  592.  
  593. void
  594. DEFUN (Move_Memory, (From, N, To),
  595.        fast SCHEME_OBJECT *From AND
  596.        long N AND
  597.        SCHEME_OBJECT *To)
  598.  
  599. {
  600.   fast SCHEME_OBJECT *Until;
  601.  
  602.   Until = &From[N];
  603.   while (From < Until)
  604.   {
  605.     *To++ = *From++;
  606.   }
  607.   return;
  608. }
  609.  
  610. #endif
  611.  
  612. #if FALSE
  613.  
  614. /* This appears to be a fossil. */
  615.  
  616. void
  617. DEFUN (Relocate_Objects, (from, how_many, disp),
  618.        fast SCHEME_OBJECT *from AND
  619.        long how_many AND
  620.        fast long disp)
  621. {
  622.   fast SCHEME_OBJECT *Until;
  623.  
  624.   Until = &from[how_many];
  625.   while (from < Until)
  626.   {
  627.     switch (OBJECT_TYPE (*from))
  628.     {
  629.       case TC_FIXNUM:
  630.       case TC_CHARACTER:
  631.         from += 1;
  632.         break;
  633.  
  634.       case TC_BIG_FIXNUM:
  635.       case TC_BIG_FLONUM:
  636.       case TC_CHARACTER_STRING:
  637.     *from++ =
  638.       (OBJECT_NEW_DATUM ((*from), (disp + (OBJECT_DATUM (*from)))));
  639.     break;
  640.  
  641.       default:
  642.     fprintf (stderr,
  643.          "%s: Unknown External Object Reference with Type 0x%02x",
  644.          program_name,
  645.          (OBJECT_TYPE (*from)));
  646.     inconsistency ();
  647.     }
  648.   }
  649.   return;
  650. }
  651.  
  652. #endif
  653.  
  654. #define Relocate_Into(Where, Addr)                    \
  655. {                                    \
  656.   if ((Addr) < Dumped_Pure_Base)                    \
  657.   {                                    \
  658.     (Where) = &Heap_Object_Base[(Addr) - Dumped_Heap_Base];        \
  659.   }                                    \
  660.   else if ((Addr) < Dumped_Constant_Base)                \
  661.   {                                    \
  662.     (Where) = &Pure_Base[(Addr) - Dumped_Pure_Base];            \
  663.   }                                    \
  664.   else                                    \
  665.   {                                    \
  666.     (Where) = &Constant_Base[(Addr) - Dumped_Constant_Base];        \
  667.   }                                    \
  668. }
  669.  
  670. #ifndef Conditional_Bug
  671.  
  672. #define Relocate(Addr)                            \
  673. (((Addr) < Dumped_Pure_Base) ?                        \
  674.  &Heap_Object_Base[(Addr) - Dumped_Heap_Base] :                \
  675.  (((Addr) < Dumped_Constant_Base) ?                    \
  676.   &Pure_Base[(Addr) - Dumped_Pure_Base] :                \
  677.   &Constant_Base[(Addr) - Dumped_Constant_Base]))
  678.  
  679. #else
  680.  
  681. static SCHEME_OBJECT *Relocate_Temp;
  682.  
  683. #define Relocate(Addr)                            \
  684.   (Relocate_Into (Relocate_Temp, Addr), Relocate_Temp)
  685.  
  686. #endif
  687.  
  688. SCHEME_OBJECT *
  689. DEFUN (Read_Pointers_and_Relocate, (how_many, to),
  690.        fast long how_many AND
  691.        fast SCHEME_OBJECT *to)
  692. {
  693.   int The_Type;
  694.   long The_Datum;
  695.  
  696. #if FALSE
  697.   ALIGN_FLOAT (to);
  698. #endif
  699.  
  700.   while ((--how_many) >= 0)
  701.   {
  702.     VMS_BUG (The_Type = 0);
  703.     VMS_BUG (The_Datum = 0);
  704.     fscanf (portable_file, "%2x %lx", &The_Type, &The_Datum);
  705.     switch (The_Type)
  706.     {
  707.       case CONSTANT_CODE:
  708.     *to++ = Constant_Table[The_Datum];
  709.     continue;
  710.  
  711.       case HEAP_CODE:
  712.     *to++ = Heap_Table[The_Datum];
  713.     continue;
  714.  
  715.       case TC_MANIFEST_NM_VECTOR:
  716.     *to++ = (MAKE_OBJECT (The_Type, The_Datum));
  717.         {
  718.       fast long count;
  719.  
  720.       count = The_Datum;
  721.       how_many -= count;
  722.       while (--count >= 0)
  723.       {
  724.         VMS_BUG (*to = 0);
  725.         fscanf (portable_file, "%lx", to++);
  726.       }
  727.     }
  728.     continue;
  729.  
  730.       case TC_COMPILED_ENTRY:
  731.       {
  732.     SCHEME_OBJECT *temp;
  733.     long base_type, base_datum;
  734.  
  735.     fscanf (portable_file, "%02x %lx", &base_type, &base_datum);
  736.     temp = (Relocate (base_datum));
  737.     *to++ =
  738.       (MAKE_POINTER_OBJECT
  739.        (base_type, ((SCHEME_OBJECT *) (&(((char *) temp)[The_Datum])))));
  740.     break;
  741.       }
  742.  
  743.       case TC_BROKEN_HEART:
  744.     if (The_Datum != 0)
  745.     {
  746.       fprintf (stderr, "%s: Broken Heart found.\n", program_name);
  747.       inconsistency ();
  748.     }
  749.     /* fall through */
  750.  
  751.       case TC_PCOMB0:
  752.       case TC_PRIMITIVE:
  753.       case TC_MANIFEST_SPECIAL_NM_VECTOR:
  754.       case_simple_Non_Pointer:
  755.     *to++ = (MAKE_OBJECT (The_Type, The_Datum));
  756.     continue;
  757.  
  758.       case TC_MANIFEST_CLOSURE:
  759.       case TC_LINKAGE_SECTION:
  760.       {
  761.     fprintf (stderr, "%s: File contains linked compiled code.\n",
  762.          program_name);
  763.     inconsistency ();
  764.       }
  765.  
  766.       case TC_REFERENCE_TRAP:
  767.     if (The_Datum <= TRAP_MAX_IMMEDIATE)
  768.     {
  769.       *to++ = (MAKE_OBJECT (The_Type, The_Datum));
  770.       continue;
  771.     }
  772.     /* It is a pointer, fall through. */
  773.  
  774.       default:
  775.     /* Should be stricter */
  776.     *to++ = (MAKE_POINTER_OBJECT (The_Type, Relocate (The_Datum)));
  777.     continue;
  778.     }
  779.   }
  780. #if FALSE
  781.   ALIGN_FLOAT (to);
  782. #endif
  783.   return (to);
  784. }
  785.  
  786. static Boolean primitive_warn = false;
  787.  
  788. SCHEME_OBJECT *
  789. DEFUN (read_primitives, (how_many, where),
  790.        fast long how_many AND
  791.        fast SCHEME_OBJECT *where)
  792. {
  793.   long arity;
  794.  
  795.   while (--how_many >= 0)
  796.   {
  797.     fscanf (portable_file, "%ld", &arity);
  798.     if (arity == ((long) UNKNOWN_PRIMITIVE_ARITY))
  799.     {
  800.       primitive_warn = true;
  801.     }
  802.     *where++ = (LONG_TO_FIXNUM (arity));
  803.     where = (read_a_string_internal (where, ((long) -1)));
  804.   }
  805.   return (where);
  806. }
  807.  
  808. #ifdef DEBUG
  809.  
  810. void
  811. DEFUN (print_external_objects, (area_name, Table, N),
  812.        char *area_name AND
  813.        fast SCHEME_OBJECT *Table AND
  814.        fast long N)
  815. {
  816.   fast SCHEME_OBJECT *Table_End = &Table[N];
  817.  
  818.   fprintf (stderr, "%s External Objects:\n", area_name);
  819.   fprintf (stderr, "Table = 0x%x; N = %d\n", Table, N);
  820.  
  821.   for ( ; Table < Table_End; Table++)
  822.   {
  823.     switch (OBJECT_TYPE (*Table))
  824.     {
  825.       case TC_FIXNUM:
  826.       {
  827.         fprintf (stderr,
  828.          "Table[%6d] = Fixnum %d\n",
  829.          (N - (Table_End - Table)),
  830.          (FIXNUM_TO_LONG (*Table)));
  831.     break;
  832.       }
  833.       case TC_CHARACTER:
  834.         fprintf (stderr,
  835.          "Table[%6d] = Character %c = 0x%02x\n",
  836.          (N - (Table_End - Table)),
  837.          (OBJECT_DATUM (*Table)),
  838.          (OBJECT_DATUM (*Table)));
  839.     break;
  840.  
  841.       case TC_CHARACTER_STRING:
  842.         fprintf (stderr,
  843.          "Table[%6d] = string \"%s\"\n",
  844.          (N - (Table_End - Table)),
  845.          ((char *) MEMORY_LOC (*Table, STRING_CHARS)));
  846.     break;
  847.  
  848.       case TC_BIG_FIXNUM:
  849.     fprintf (stderr,
  850.          "Table[%6d] = Bignum\n",
  851.          (N - (Table_End - Table)));
  852.     break;
  853.  
  854.       case TC_BIG_FLONUM:
  855.     fprintf (stderr,
  856.          "Table[%6d] = Flonum %lf\n",
  857.          (N - (Table_End - Table)),
  858.          (* ((double *) MEMORY_LOC (*Table, 1))));
  859.     break;
  860.  
  861.       default:
  862.         fprintf (stderr,
  863.          "Table[%6d] = Unknown External Object 0x%8x\n",
  864.          (N - (Table_End - Table)),
  865.          *Table);
  866.     break;
  867.     }
  868.   }
  869.   return;
  870. }
  871.  
  872. #define DEBUGGING(action)        action
  873.  
  874. #define WHEN(condition, message)    when (condition, message)
  875.  
  876. void
  877. DEFUN (when, (what, message),
  878.        Boolean what AND
  879.        char *message)
  880. {
  881.   if (what)
  882.   {
  883.     fprintf (stderr, "%s: Inconsistency: %s!\n",
  884.          program_name, (message));
  885.     quit (1);
  886.   }
  887.   return;
  888. }
  889.  
  890. #define READ_HEADER(string, format, value)                \
  891. {                                    \
  892.  fscanf (portable_file, format, &(value));                \
  893.  fprintf (stderr, "%s: ", (string));                    \
  894.  fprintf (stderr, (format), (value));                    \
  895.  fprintf (stderr, "\n");                        \
  896. }
  897.  
  898. #else /* not DEBUG */
  899.  
  900. #define DEBUGGING(action)
  901.  
  902. #define WHEN(what, message)
  903.  
  904. #define READ_HEADER(string, format, value)                \
  905. {                                    \
  906.   if (fscanf (portable_file, format, &(value)) == EOF)            \
  907.   {                                    \
  908.     short_header_read ();                        \
  909.   }                                    \
  910. }
  911.  
  912. #endif /* DEBUG */
  913.  
  914. void
  915. DEFUN_VOID (short_header_read)
  916. {
  917.   fprintf (stderr, "%s: Header is not complete!\n", program_name);
  918.   quit (1);
  919. }
  920.  
  921. static SCHEME_OBJECT *Storage;
  922.  
  923. long
  924. DEFUN_VOID (Read_Header_and_Allocate)
  925. {
  926.   long
  927.     Portable_Version, Machine,
  928.     Version, Sub_Version, Flags,
  929.     NFlonums, NIntegers, NBits,
  930.     NBitstrs, NBBits, NStrings, NChars,
  931.     NPChars,
  932.     Size;
  933.  
  934. #if FALSE
  935.   READ_HEADER ("Portable Version", "%ld", Portable_Version);
  936. #else
  937.   if (fscanf (portable_file, "%ld", &Portable_Version) == EOF)
  938.   {
  939.     return (-1);
  940.   }
  941. #endif
  942.  
  943.   if (Portable_Version != PORTABLE_VERSION)
  944.   {
  945.     fprintf (stderr, "%s: Portable version mismatch:\n", program_name);
  946.     fprintf (stderr, "Portable File Version %4d\n", Portable_Version);
  947.     fprintf (stderr, "Expected:     Version %4d\n", PORTABLE_VERSION);
  948.     quit (1);
  949.   }
  950.  
  951.   READ_HEADER ("Machine", "%ld", Machine);
  952.   READ_HEADER ("Version", "%ld", Version);
  953.   READ_HEADER ("Sub Version", "%ld", Sub_Version);
  954.  
  955.   if ((Version != FASL_FORMAT_VERSION)        ||
  956.       (Sub_Version != FASL_SUBVERSION))
  957.   {
  958.     fprintf (stderr, "%s: Binary version mismatch:\n", program_name);
  959.     fprintf (stderr,
  960.          "Portable File Version %4d; Binary Version %4d; Subversion %4d\n",
  961.          Portable_Version, Version, Sub_Version);
  962.     fprintf (stderr,
  963.          "Expected:     Version %4d; Binary Version %4d; Subversion %4d\n",
  964.          PORTABLE_VERSION, FASL_FORMAT_VERSION, FASL_SUBVERSION);
  965.     quit (1);
  966.   }
  967.  
  968.   READ_HEADER ("Flags", "%ld", Flags);
  969.   READ_FLAGS (Flags);
  970.  
  971.   if (((compiled_p && (! allow_compiled_p)) ||
  972.        (nmv_p && (! allow_nmv_p))) &&
  973.       (Machine != FASL_INTERNAL_FORMAT))
  974.   {
  975.     if (compiled_p)
  976.     {
  977.       fprintf (stderr, "%s: %s\n", program_name,
  978.            "Portable file contains \"non-portable\" compiled code.");
  979.     }
  980.     else
  981.     {
  982.       fprintf (stderr, "%s: %s\n", program_name,
  983.            "Portable file contains \"unexpected\" non-marked vectors.");
  984.     }
  985.     fprintf (stderr, "Machine specified in the portable file: %4d\n",
  986.          Machine);
  987.     fprintf (stderr, "Machine Expected:                       %4d\n",
  988.          FASL_INTERNAL_FORMAT);
  989.     quit (1);
  990.   }
  991.  
  992.   READ_HEADER ("Heap Count", "%ld", Heap_Count);
  993.   READ_HEADER ("Dumped Heap Base", "%ld", Dumped_Heap_Base);
  994.   READ_HEADER ("Heap Objects", "%ld", Heap_Objects);
  995.  
  996.   READ_HEADER ("Constant Count", "%ld", Constant_Count);
  997.   READ_HEADER ("Dumped Constant Base", "%ld", Dumped_Constant_Base);
  998.   READ_HEADER ("Constant Objects", "%ld", Constant_Objects);
  999.  
  1000.   READ_HEADER ("Pure Count", "%ld", Pure_Count);
  1001.   READ_HEADER ("Dumped Pure Base", "%ld", Dumped_Pure_Base);
  1002.   READ_HEADER ("Pure Objects", "%ld", Pure_Objects);
  1003.  
  1004.   READ_HEADER ("& Dumped Object", "%ld", Dumped_Object_Addr);
  1005.  
  1006.   READ_HEADER ("Number of flonums", "%ld", NFlonums);
  1007.   READ_HEADER ("Number of integers", "%ld", NIntegers);
  1008.   READ_HEADER ("Number of bits in integers", "%ld", NBits);
  1009.   READ_HEADER ("Number of bit strings", "%ld", NBitstrs);
  1010.   READ_HEADER ("Number of bits in bit strings", "%ld", NBBits);
  1011.   READ_HEADER ("Number of character strings", "%ld", NStrings);
  1012.   READ_HEADER ("Number of characters in strings", "%ld", NChars);
  1013.  
  1014.   READ_HEADER ("Primitive Table Length", "%ld", Primitive_Table_Length);
  1015.   READ_HEADER ("Number of characters in primitives", "%ld", NPChars);
  1016.  
  1017.   READ_HEADER ("CPU type", "%ld", compiler_processor_type);
  1018.   READ_HEADER ("Compiled code interface version", "%ld",
  1019.            compiler_interface_version);
  1020. #if FALSE
  1021.   READ_HEADER ("Compiler utilities vector", "%ld", compiler_utilities);
  1022. #endif
  1023.  
  1024.   Size = (6 +                        /* SNMV */
  1025.       HEAP_BUFFER_SPACE +
  1026.       Heap_Count + Heap_Objects +
  1027.       Constant_Count + Constant_Objects +
  1028.       Pure_Count + Pure_Objects +
  1029.       flonum_to_pointer (NFlonums) +
  1030.       ((NIntegers * (2 + (BYTES_TO_WORDS (sizeof (bignum_digit_type))))) +
  1031.        (BYTES_TO_WORDS (BIGNUM_BITS_TO_DIGITS (NBits)))) +
  1032.       ((NStrings * (1 + STRING_CHARS)) +
  1033.        (char_to_pointer (NChars))) +
  1034.       ((NBitstrs * (1 + BIT_STRING_FIRST_WORD)) +
  1035.        (BIT_STRING_LENGTH_TO_GC_LENGTH (NBBits))) +
  1036.       ((Primitive_Table_Length * (2 + STRING_CHARS)) +
  1037.        (char_to_pointer (NPChars))));
  1038.  
  1039.   ALLOCATE_HEAP_SPACE (Size);
  1040.   if (Heap == NULL)
  1041.   {
  1042.     fprintf (stderr,
  1043.          "%s: Memory Allocation Failed.  Size = %ld Scheme Objects\n",
  1044.          program_name, Size);
  1045.     quit (1);
  1046.   }
  1047.   Storage = Heap;
  1048.   Heap += (TRAP_MAX_IMMEDIATE + 1);
  1049.   return (Size - (TRAP_MAX_IMMEDIATE + 1));
  1050. }
  1051.  
  1052. void
  1053. DEFUN_VOID (do_it)
  1054. {
  1055.   while (1)
  1056.   {
  1057.     SCHEME_OBJECT *primitive_table_end;
  1058.     Boolean result;
  1059.     long Size;
  1060.  
  1061.     Size = (Read_Header_and_Allocate ());
  1062.     if (Size < 0)
  1063.     {
  1064.       return;
  1065.     }
  1066.  
  1067.     Stack_Top = &Heap[Size];
  1068.     DEBUGGING (fprintf (stderr, "Stack_Top: 0x%x\n", Stack_Top));
  1069.  
  1070.     Heap_Table = &Heap[0];
  1071.     Heap_Base = &Heap_Table[Heap_Objects];
  1072.     ALIGN_FLOAT (Heap_Base);
  1073.     Heap_Object_Base =
  1074.       Read_External (Heap_Objects, Heap_Table, Heap_Base);
  1075.     DEBUGGING (print_external_objects ("Heap", Heap_Table, Heap_Objects));
  1076.     DEBUGGING (fprintf (stderr, "Heap_Base: 0x%x\n", Heap_Base));
  1077.     DEBUGGING (fprintf (stderr, "Heap_Object_Base: 0x%x\n", Heap_Object_Base));
  1078.  
  1079.     /* The various 2s below are for SNMV headers. */
  1080.  
  1081.     Pure_Table = &Heap_Object_Base[Heap_Count];
  1082.     Pure_Base = &Pure_Table[Pure_Objects + 2];
  1083.     Pure_Object_Base =
  1084.       Read_External (Pure_Objects, Pure_Table, Pure_Base);
  1085.     DEBUGGING (print_external_objects ("Pure", Pure_Table, Pure_Objects));
  1086.     DEBUGGING (fprintf (stderr, "Pure_Base: 0x%x\n", Pure_Base));
  1087.     DEBUGGING (fprintf (stderr, "Pure_Object_Base: 0x%x\n", Pure_Object_Base));
  1088.  
  1089.     Constant_Table = &Heap[Size - Constant_Objects];
  1090.     Constant_Base = &Pure_Object_Base[Pure_Count + 2];
  1091.     Constant_Object_Base =
  1092.       Read_External (Constant_Objects, Constant_Table, Constant_Base);
  1093.     DEBUGGING (print_external_objects ("Constant",
  1094.                        Constant_Table,
  1095.                        Constant_Objects));
  1096.     DEBUGGING (fprintf (stderr, "Constant_Base: 0x%x\n", Constant_Base));
  1097.     DEBUGGING (fprintf (stderr, "Constant_Object_Base: 0x%x\n",
  1098.             Constant_Object_Base));
  1099.  
  1100.     primitive_table = &Constant_Object_Base[Constant_Count + 2];
  1101.  
  1102.     WHEN ((primitive_table > Constant_Table),
  1103.       "primitive_table overran Constant_Table");
  1104.  
  1105.     /* Read the normal objects */
  1106.  
  1107.     Free =
  1108.       Read_Pointers_and_Relocate (Heap_Count, Heap_Object_Base);
  1109.  
  1110.     WHEN ((Free > Pure_Table),
  1111.       "Free overran Pure_Table");
  1112.     WHEN ((Free < Pure_Table),
  1113.       "Free did not reach Pure_Table");
  1114.  
  1115.     Free_Pure =
  1116.       Read_Pointers_and_Relocate (Pure_Count, Pure_Object_Base);
  1117.  
  1118.     WHEN ((Free_Pure > (Constant_Base - 2)),
  1119.       "Free_Pure overran Constant_Base");
  1120.     WHEN ((Free_Pure < (Constant_Base - 2)),
  1121.       "Free_Pure did not reach Constant_Base");
  1122.  
  1123.     Free_Constant =
  1124.       Read_Pointers_and_Relocate (Constant_Count, Constant_Object_Base);
  1125.  
  1126.     WHEN ((Free_Constant > (primitive_table - 2)),
  1127.       "Free_Constant overran primitive_table");
  1128.     WHEN ((Free_Constant < (primitive_table - 2)),
  1129.       "Free_Constant did not reach primitive_table");
  1130.  
  1131.     primitive_table_end =
  1132.       read_primitives (Primitive_Table_Length, primitive_table);
  1133.  
  1134.     /*
  1135.       primitive_table_end can be well below Constant_Table, since
  1136.       the memory allocation is conservative (it rounds up), and all
  1137.       the slack ends up between them.
  1138.       */
  1139.  
  1140.     WHEN ((primitive_table_end > Constant_Table),
  1141.       "primitive_table_end overran Constant_Table");
  1142.  
  1143.     if (primitive_warn)
  1144.     {
  1145.       fprintf (stderr, "%s:\n", program_name);
  1146.       fprintf (stderr,
  1147.            "NOTE: The binary file contains primitives with unknown arity.\n");
  1148.     }
  1149.  
  1150.     /* Dump the objects */
  1151.  
  1152.   {
  1153.     SCHEME_OBJECT *Dumped_Object;
  1154.  
  1155.     Relocate_Into (Dumped_Object, Dumped_Object_Addr);
  1156.  
  1157.     DEBUGGING (fprintf (stderr, "Dumping:\n"));
  1158.     DEBUGGING (fprintf (stderr,
  1159.             "Heap = 0x%x; Heap Count = %d\n",
  1160.             Heap_Base, (Free - Heap_Base)));
  1161.     DEBUGGING (fprintf (stderr,
  1162.             "Pure Space = 0x%x; Pure Count = %d\n",
  1163.             Pure_Base, (Free_Pure - Pure_Base)));
  1164.     DEBUGGING (fprintf (stderr,
  1165.             "Constant Space = 0x%x; Constant Count = %d\n",
  1166.             Constant_Base, (Free_Constant - Constant_Base)));
  1167.     DEBUGGING (fprintf (stderr,
  1168.             "& Dumped Object = 0x%x; Dumped Object = 0x%x\n",
  1169.             Dumped_Object, *Dumped_Object));
  1170.     DEBUGGING (fprintf (stderr, "Primitive_Table_Length = %ld; ",
  1171.             Primitive_Table_Length));
  1172.     DEBUGGING (fprintf (stderr, "Primitive_Table_Size = %ld\n",
  1173.             (primitive_table_end - primitive_table)));
  1174.  
  1175.     /* Is there a Pure/Constant block? */
  1176.  
  1177.     if ((Constant_Objects == 0) && (Constant_Count == 0) &&
  1178.     (Pure_Objects == 0) && (Pure_Count == 0))
  1179.     {
  1180.       result = Write_File (Dumped_Object,
  1181.                (Free - Heap_Base), Heap_Base,
  1182.                0, Stack_Top,
  1183.                primitive_table, Primitive_Table_Length,
  1184.                ((long) (primitive_table_end - primitive_table)),
  1185.                compiled_p, band_p);
  1186.     }
  1187.     else
  1188.     {
  1189.       long Pure_Length, Total_Length;
  1190.  
  1191.       Pure_Length = (Constant_Base - Pure_Base) + 1;
  1192.       Total_Length = (Free_Constant - Pure_Base) + 4;
  1193.       Pure_Base[-2] =
  1194.     MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, (Pure_Length - 1));
  1195.       Pure_Base[-1] =
  1196.     MAKE_OBJECT (PURE_PART, Total_Length);
  1197.       Constant_Base[-2] =
  1198.     MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
  1199.       Constant_Base[-1] =
  1200.     MAKE_OBJECT (CONSTANT_PART, (Pure_Length - 1));
  1201.       Free_Constant[0] =
  1202.     MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
  1203.       Free_Constant[1] =
  1204.     MAKE_OBJECT (END_OF_BLOCK, Total_Length);
  1205.  
  1206.       result = (Write_File (Dumped_Object,
  1207.                 (Free - Heap_Base), Heap_Base,
  1208.                 Total_Length, (Pure_Base - 2),
  1209.                 primitive_table, Primitive_Table_Length,
  1210.                 ((long) (primitive_table_end - primitive_table)),
  1211.                 compiled_p, band_p));
  1212.     }
  1213.   }
  1214.     if (!result)
  1215.     {
  1216.       fprintf (stderr, "%s: Error writing the output file.\n", program_name);
  1217.       quit (1);
  1218.     }
  1219.     free ((char *) Storage);
  1220.   }
  1221. }
  1222.  
  1223. /* Top level */
  1224.  
  1225. static Boolean
  1226.   help_p = false,
  1227.   help_sup_p;
  1228.  
  1229. static struct keyword_struct
  1230.   options[] = {
  1231.     KEYWORD ("allow_nmv", &allow_nmv_p, BOOLEAN_KYWRD, BFRMT, NULL),
  1232.     KEYWORD ("allow_cc", &allow_compiled_p, BOOLEAN_KYWRD, BFRMT, NULL),
  1233.     KEYWORD ("help", &help_p, BOOLEAN_KYWRD, BFRMT, &help_sup_p),
  1234.     OUTPUT_KEYWORD (),
  1235.     INPUT_KEYWORD (),
  1236.     END_KEYWORD ()
  1237.     };
  1238.  
  1239. DEFUN (main, (argc, argv),
  1240.        int argc AND
  1241.        char **argv)
  1242. {
  1243.   parse_keywords (argc, argv, options, false);
  1244.   if (help_sup_p && help_p)
  1245.   {
  1246.     print_usage_and_exit (options, 0);
  1247.     /*NOTREACHED*/
  1248.   }
  1249.   allow_nmv_p = (allow_nmv_p || allow_compiled_p);
  1250.  
  1251.   setup_io ("r", "wb");
  1252.   do_it ();
  1253.   quit (0);
  1254. }
  1255.